The CICA Windows Explosion!/The CICA Windows Explosion! - Disc 2.iso/programr/iceb3r1.zip/ice.frm

Text File | 1995-05-03 | 14KB | 423 lines

VERSION 2.00
Begin Form frmICE
   BackColor       =   &H00C0C0C0&
   BorderStyle     =   3  'Fixed Double
   Caption         =   "ICE - VB Demonstration"
   ClientHeight    =   4410
   ClientLeft      =   1185
   ClientTop       =   1575
   ClientWidth     =   7680
   ClipControls    =   0   'False
   Height          =   4815
   Icon            =   ICE.FRX:0000
   Left            =   1125
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4410
   ScaleWidth      =   7680
   Top             =   1230
   Width           =   7800
   Begin CommandButton cmdAbout
      Caption         =   "About"
      Height          =   315
      Left            =   2925
      TabIndex        =   20
      Top             =   2850
      Width           =   1215
   End
   Begin CommandButton cmdAdd
      Caption         =   "&Add -->"
      Height          =   315
      Left            =   2925
      TabIndex        =   6
      Top             =   300
      Width           =   1215
   End
   Begin DriveListBox Drive1
      Height          =   315
      Left            =   75
      TabIndex        =   5
      Top             =   3225
      Width           =   2640
   End
   Begin DirListBox Dir1
      Height          =   1155
      Left            =   75
      TabIndex        =   3
      Top             =   1800
      Width           =   2640
   End
   Begin FileListBox File1
      Height          =   1200
      Left            =   75
      MultiSelect     =   2  'Extended
      TabIndex        =   1
      Top             =   300
      Width           =   2640
   End
   Begin ListBox lstContents
      Height          =   1980
      Left            =   4350
      Sorted          =   -1  'True
      TabIndex        =   12
      Top             =   900
      Width           =   3240
   End
   Begin TextBox txtArchive
      Height          =   315
      Left            =   4350
      TabIndex        =   9
      Top             =   300
      Width           =   1965
   End
   Begin Frame Frame1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Options"
      Height          =   1215
      Left            =   4350
      TabIndex        =   13
      Top             =   3075
      Width           =   3240
      Begin CheckBox cckOverwrite
         BackColor       =   &H00C0C0C0&
         Caption         =   "Over&write existing files"
         Height          =   315
         Left            =   375
         TabIndex        =   15
         Top             =   675
         Width           =   2340
      End
      Begin CheckBox cckMove
         BackColor       =   &H00C0C0C0&
         Caption         =   "&Move files"
         Height          =   240
         Left            =   375
         TabIndex        =   14
         Top             =   375
         Width           =   1215
      End
   End
   Begin CommandButton cmdBrowse
      Caption         =   "&Browse"
      Height          =   315
      Left            =   6375
      TabIndex        =   10
      Top             =   300
      Width           =   1215
   End
   Begin CommonDialog CMDialog1
      DefaultExt      =   "LZH"
      DialogTitle     =   "Open Archive"
      Filter          =   "LHA files (*.LZH)|*.LZH|All files (*.*)|*.*"
      Left            =   75
      Top             =   3825
   End
   Begin TextBox txtHidden
      Height          =   465
      Left            =   2700
      TabIndex        =   18
      Top             =   3900
      Visible         =   0   'False
      Width           =   1740
   End
   Begin PictureBox picStatus
      FillColor       =   &H0000FF00&
      ForeColor       =   &H0000FF00&
      Height          =   315
      Left            =   75
      ScaleHeight     =   285
      ScaleWidth      =   4035
      TabIndex        =   17
      Top             =   3675
      Width           =   4065
   End
   Begin CommandButton cmdExtract
      Caption         =   "<-- &Extract"
      Height          =   315
      Left            =   2925
      TabIndex        =   7
      Top             =   675
      Width           =   1215
   End
   Begin CommandButton cmdClose
      Caption         =   "&Close"
      Height          =   315
      Left            =   2925
      TabIndex        =   16
      Top             =   3225
      Width           =   1215
   End
   Begin Label lblArchive
      BackColor       =   &H00C0C0C0&
      Caption         =   "Arc&hive file:"
      Height          =   225
      Left            =   4350
      TabIndex        =   8
      Top             =   75
      Width           =   1215
   End
   Begin Label lblFiles
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Files:"
      Height          =   225
      Left            =   75
      TabIndex        =   0
      Top             =   75
      Width           =   1215
   End
   Begin Label lblDir
      BackColor       =   &H00C0C0C0&
      Caption         =   "&Directories:"
      Height          =   225
      Left            =   75
      TabIndex        =   2
      Top             =   1575
      Width           =   1215
   End
   Begin Label lblDrives
      AutoSize        =   -1  'True
      BackColor       =   &H00C0C0C0&
      Caption         =   "Dri&ves:"
      Height          =   195
      Left            =   75
      TabIndex        =   4
      Top             =   3000
      Width           =   615
   End
   Begin Label lblContents
      BackColor       =   &H00C0C0C0&
      Caption         =   "C&ontents:"
      Height          =   240
      Left            =   4350
      TabIndex        =   11
      Top             =   675
      Width           =   1215
   End
   Begin Label lblStatus
      Alignment       =   2  'Center
      BorderStyle     =   1  'Fixed Single
      Caption         =   "Idle"
      FontBold        =   0   'False
      FontItalic      =   0   'False
      FontName        =   "MS Sans Serif"
      FontSize        =   8.25
      FontStrikethru  =   0   'False
      FontUnderline   =   0   'False
      Height          =   240
      Left            =   75
      TabIndex        =   19
      Top             =   4050
      Width           =   4065
   End
End
' ---------------------------------------------------------
'       Copyright (C) 1995 Stephen Darlington
'
' You have a royalty-free right to use, modify, reproduce,
' and distribute the ICE sample application files
' (and/or any modified version) in any way you find useful,
' subject to the limitations outlined in the ICE help file,
' and provided that you agree that Stephen Darlington has no
' warranty, obligations, or liability for any sample
' application files.
' ---------------------------------------------------------

Option Explicit
Declare Function BitBlt Lib "GDI" (ByVal hDestDC As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nWidth As Integer, ByVal nHeight As Integer, ByVal hSrcDC As Integer, ByVal XSrc As Integer, ByVal YSrc As Integer, ByVal dwRop As Long) As Integer
Declare Sub ShellAbout Lib "shell.dll" (ByVal hWndOwner As Integer, ByVal lpszAppName As String, ByVal lpszMoreInfo As String, ByVal hIcon As Integer)
Declare Function SendMessage Lib "User" (ByVal hWnd As Integer, ByVal wMsg As Integer, ByVal wParam As Integer, lparam As Any) As Long
Const WM_USER = &H400
Const LB_SETTABSTOPS = WM_USER + 19
Dim ICEaction As String

Sub cmdAbout_Click ()
    Dim sMore$
    sMore$ = "This is a Visual Basic example program "
    sMore$ = sMore$ & "to demonstrate the ICE Compression Library"
    Call ShellAbout(Me.hWnd, App.Title, sMore$, Me.Icon)
End Sub

Sub cmdAdd_Click ()
    Dim i As Integer
    Dim lFlags As Long
    Dim iAdded As Integer
    Dim rv As Integer
    Dim afile$
    Dim msg$
    '
    ICEaction = "Freezing"
    iAdded = False
    lFlags = 0
    If (cckMove.Value = 1) Then lFlags = lFlags + ICE_MOVEFILES
    If (cckOverwrite.Value = 1) Then lFlags = lFlags + ICE_OVERWRITEALL
    For i = 0 To file1.ListCount - 1
        If file1.Selected(i) Then
            afile$ = file1.Path
            If (Right$(afile$, 1) <> "\") Then afile$ = afile$ & "\"
            afile$ = afile$ & file1.List(i)
            rv = Freeze(afile$, txtArchive.Text, lFlags)
            If (rv < 0) Then
                msg$ = "Error " & Format$(rv) & " occured. "
                msg$ = msg$ & "Please refer to the ICE help file."
                MsgBox msg$, 15, "Error returned from ICE"
            End If
            iAdded = True
        End If
    Next i
    If iAdded Then ShowContents
    lblStatus.Caption = "Idle"
    picStatus.Cls
    DoEvents
End Sub

Sub cmdBrowse_Click ()
    Const OFN_CREATEPROMPT = &H2000&    'Specifies that the dialog box should ask if the user wants to create a file that does not currently exist. This flag automatically sets the OFN_PATHMUSTEXIST and OFN_FILEMUSTEXIST flags.
    Const OFN_HIDEREADONLY = &H4&       'Hides the Read Only check box.
    Const OFN_NOCHANGEDIR = &H8&        'Forces the dialog box to set the current directory to what it was when the dialog box was invoked.
    Const OFN_PATHMUSTEXIST = &H800&    'Specifies that the user can enter only valid path names. If this flag is set and the user enters an invalid path name, a warning message is displayed.
    '
    CMDialog1.Flags = OFN_CREATEPROMPT + OFN_HIDEREADONLY + OFN_NOCHANGEDIR + OFN_PATHMUSTEXIST
    CMDialog1.CancelError = True
    On Error GoTo CancelError
    CMDialog1.Action = 1
    On Error GoTo 0
    DoEvents
    txtArchive.Text = CMDialog1.Filename
    Call ShowContents
    Exit Sub
CancelError:
    On Error GoTo 0
    Exit Sub
End Sub

Sub cmdClose_Click ()
    End3D
    End
End Sub

Sub cmdExtract_Click ()
    Dim i As Integer
    Dim rv As Integer
    Dim lFlags As Long
    Dim sFile$
    Dim msg$
    Dim Current$
    '
    ICEaction = "Thawing"
    Current$ = CurDir$
    ChDir file1.Path
    lFlags = 0
    If (cckMove.Value = 1) Then lFlags = lFlags + ICE_MOVEFILES
    If (cckOverwrite.Value = 1) Then lFlags = lFlags + ICE_OVERWRITEALL
    For i = 0 To lstContents.ListCount - 1
        If lstContents.Selected(i) Then
            sFile$ = GetPiece(Format$(lstContents.List(i)), Chr(9), 1)
            rv = Thaw(sFile$, txtArchive.Text, lFlags)
            If (rv < 0) Then
                msg$ = "Error " & Format$(rv) & " occured. "
                msg$ = msg$ & "Please refer to the ICE help file."
                MsgBox msg$, 15, "Error returned from ICE"
            End If
        End If
    Next i
    lblStatus.Caption = "Idle"
    picStatus.Cls
    file1.Refresh
    ChDir Current$
    DoEvents
End Sub

Sub Dir1_Change ()
    file1.Path = Dir1.Path  ' When Dir changes, set File path.
End Sub

Sub Drive1_Change ()
    Dir1.Path = Drive1.Drive    ' When Drive changes, set Dir path.
End Sub

Sub Form_Load ()
    Static iTabs(2) As Integer ' the location of the tab stops
    Dim sAlphabet$             ' the alphabet
    Dim AvgChar As Single      ' the width of an average character
    Dim iSpacer As Integer     ' the gaps between columns
    Dim lReturn As Long        ' the value returned from SendMessage
    '
    sAlphabet$ = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
    AvgChar = (Me.TextWidth(sAlphabet) / 52) / screen.TwipsPerPixelX
    iSpacer = AvgChar * 2
    ' set the tab stop for the maximum possible width of a file name
    iTabs(1) = ((Me.TextWidth("MMMMMMMM.MMM") / screen.TwipsPerPixelX + iSpacer) \ AvgChar) * 4
    ' set the next tab stop for the maximum possible width of the compression ratio
    iTabs(2) = iTabs(1) + ((Me.TextWidth("MMMM") / screen.TwipsPerPixelX + iSpacer) \ AvgChar) * 4
    ' set the tab stops for the listbox
    lReturn = SendMessage(lstContents.hWnd, LB_SETTABSTOPS, 1, iTabs(1))
    '
    ' setup the picturebox as a status bar
    picStatus.AutoRedraw = True
    picStatus.DrawMode = 10
    picStatus.FillStyle = 0
    '
    ' Initialise the ICE library
    Call InitialiseICE(Me.hWnd, txtHidden.hWnd, ICE_PASSPERCENT Or ICE_PASSFILENAME)

    ' Get instance handle of project
    hInstance = GetInstance(Me)
    ' start the 3D functions
    Start3D
    ' show this form as 3D
    Make3D Me
End Sub

Sub Form_Unload (Cancel As Integer)
    ' stop the 3D functions
    End3D
End Sub

Sub ShowContents ()
    Dim i As Integer
    Dim iCounter As Integer
    Dim sLZHfile$
    ReDim files(10) As ICEINFO_TYPE
    '
    lstContents.Clear
    sLZHfile$ = txtArchive.Text
    If (Dir$(sLZHfile$) = "") Then Exit Sub
    iCounter = ListArchiveContents("*.*", sLZHfile$, files())
    For i = 1 To iCounter
        lstContents.AddItem files(i).sFilename & Chr(9) & files(i).sRatio
    Next i
End Sub

Sub txtArchive_KeyPress (keyAscii As Integer)
    ' only retrieve the contenst of the file if the user presses return
    If (keyAscii = 13) Then Call ShowContents
End Sub

Sub txtHidden_Change ()
    '
    ' this is where VB can react to information passed by ICE.
    Dim pct As Integer
    '
    pct = Val(GetPiece(Format$(txtHidden.Text), "#", 2))
    Call UpdateStatus(pct)
    lblStatus = ICEaction & " " & GetPiece(Format$(txtHidden.Text), "#", 1)
    DoEvents
End Sub

Sub UpdateStatus (pctValue As Integer)
    Dim pct$
    Dim rv As Integer
    Const SRCCOPY = &HCC0020

    pct$ = Format$(pctValue) & "%"
    picStatus.Cls
    picStatus.CurrentX = (picStatus.ScaleWidth - picStatus.TextWidth(pct$)) \ 2
    picStatus.CurrentY = (picStatus.ScaleHeight - picStatus.TextHeight(pct$)) \ 2
    picStatus.Print pct$
    picStatus.Line (0, 0)-(pctValue * picStatus.ScaleWidth / 100, picStatus.ScaleHeight), picStatus.ForeColor, BF
    rv = BitBlt(picStatus.hDC, 0, 0, picStatus.ScaleWidth, picStatus.ScaleHeight, picStatus.hDC, 0, 0, SRCCOPY)
    DoEvents
End Sub